home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / More classes / MW documents / MW3⁄4ut < prev    next >
Text File  |  1990-03-01  |  14KB  |  584 lines
  1. \ Utility routines etc. for Word 3.0 documents.
  2.  
  3.     0    value    BUF_START
  4.     0    value    STLS        \ Holds copy of styles byte of current format
  5.     0    value    OPTIONS        \ Holds copy of options byte
  6.     0    value    DOING_PARAS?
  7.  
  8.  
  9. \ The following words handle the "change information" that is present if
  10. \ the document was saved using "Fast save".  This is fairly complicated,
  11. \ so we hope we've got it right.  If we don't recognize something, we set
  12. \ MYSTERY? true and put the code we didn't recognize into UNPROCESSED_CODE,
  13. \ so the application can warn the user that there may be problems.  These
  14. \ problems may be insignificant, which is why we don't give a hard error.
  15.  
  16.     0    value    #CHANGES
  17.     0    value    OPCODE        \ Holds op code for style etc. override
  18.     0    value    OVERRIDE_MARKER
  19.     0    value    NEW_CHANGE_BLK?
  20.     0    value    FMT_STRT
  21.     0    value    CHG-BLK?
  22.     0    value    CHGD-BLK?    \ True if previous offset was in a new chg blk
  23.     0    value    OV_BLK#
  24.  
  25. false    value    OV_ON?
  26.  
  27. \         ============== Setting up ================
  28.  
  29. : LOCATE_NEW_CHANGE  { offs -- }
  30.     reset: changes
  31.     BEGIN
  32.         len: changes  0EXIT
  33.         offs  ^1st: changes @  <  ?EXIT
  34.         14 skip: changes
  35.     AGAIN   ;
  36.  
  37.  
  38.  
  39. local  FIX_OVERRIDE  { \ this_dst -- }
  40.  
  41. : SETUP_OFFSETS
  42.     true -> ov_on?        \ Forces generation of a fmt_ov_run entry to 
  43.                 \ turn overrides off at the start
  44.     tmp dup  copyto: src  copyto: dst
  45.     len: tmp  2/ 2/ 1- 3 /  -> #changes
  46.     #changes 1+ 4*  skip: src
  47.     4 nxtn: dst  -> this_dst
  48.     #changes 0
  49.     ?DO
  50.         pause
  51.         2 skip: src
  52.         4 nxtn: src  hdr_len -        \ source offset - save
  53.         dup  locate_new_change
  54.         2 nxtn: src  -> override_marker
  55.         ( this_dst ) fix_override    \ Note: uses PAD
  56.         pad !                \ source offset to PAD
  57.         4 nxtn: dst dup this_dst -  pad 4+ !    \ length
  58.         this_dst  pad 8 + !        \ dest offset
  59.         -> this_dst
  60.         override_marker  pad 12 + w!    \ override marker
  61.         pad 14  insert: changes        \ Move new entry in from PAD
  62.     LOOP  ;
  63.  
  64.  
  65. : SU_STYL_OV
  66.     nxtc: tmp
  67.     dup  $ 80 <>  and    \ 0 or $ 80 mean off, anything else means
  68.     0<> negate        \  on ... I hope ...
  69.     opcode  $ 1E  -  ^1st: fmt_ov_str  +  c!  ;
  70.  
  71. : SU_FONT_OV
  72.     2 nxtn: tmp  ^1st: fmt_ov_str  10 +  w!  ;
  73.  
  74. : SU_SIZ_OV
  75.     nxtc: tmp  2/  ^1st: fmt_ov_str  9 +  c!  ;
  76.  
  77. : SU_UND_OV
  78.     nxtc: tmp  2*  ^1st: fmt_ov_str  8 +  c!  ;
  79.  
  80. : SU_VD_OV
  81.     nxtc: tmp   dup  $ 80 =
  82.     IF  drop  0  THEN
  83.     ^1st: fmt_ov_str  12 +  c!   ;
  84.  
  85. : SU_HD_OV
  86.     nxtc: tmp  $ 40 -  2* 2*
  87.     ^1st: fmt_ov_str  13 +  c!  ;
  88.  
  89. : SU_PARA_OV1
  90.     1 skip: tmp  ;
  91.  
  92. \    opcode 5 =
  93. \    IF    nxtc: tmp  ^1st: para_ov_str  w!
  94. \    ELSE    1 skip: tmp           \ We're not handling these others
  95. \    THEN   ;
  96.  
  97. : SU_PARA_OV2
  98.     2 skip: tmp  ;
  99.  
  100. \    2 nxtn: tmp
  101. \    opcode dup $ 13 >= -  $ E - 2*  ^1st: para_ov_str +  w!   ;
  102.  
  103. : SU_STYL#_OV
  104.     nxtc: tmp
  105.     ^1st: para_ov_str ( 2+ )  w!  ;
  106.  
  107. : SU_OUTL_OV
  108.     nxtc: tmp  2+            \ outlining level no.
  109.     1 max  9 min            \ just in case
  110.     negate  $ FF  and  ^1st: para_ov_str ( 2+ )  w!  ;
  111.  
  112. : SU_SECT_OV
  113.     this_dst  +L: sect_ov_str  nxtc: tmp  +W: sect_ov_str  ;
  114.  
  115.  
  116. : SETUP_1_OVERRIDE
  117.     nxtc: tmp  dup  -> opcode
  118.     CASE[
  119.         $ 1E  $ 25    RANGE]=>    su_styl_ov
  120.      [  $ 05  $ 0B    RANGE]=>    su_para_ov1
  121.      [  $ 10  $ 15    RANGE]=>    su_para_ov2
  122.      [  $ 02    ]=>    su_styl#_ov
  123.      [  $ 04    ]=>    su_outl_ov
  124.      [  $ 0F    ]=>  ( tabs - we're ignoring them )
  125.                 nxtc: tmp ( length )  skip: tmp
  126.      [  $ 26    ]=>    su_font_ov
  127.      [ $ 27 ], [ $ 45 ]=>    su_und_ov    \ The 45 can come in W4 docs
  128.      [  $ 28    ]=>    su_siz_ov
  129.      [  0        ]=>    su_VD_ov
  130.      [  $ 29    ]=>    su_HD_ov
  131.      [  $ 41    ]=>    su_sect_ov
  132.      [  $ 1D    ]=>  ( pass - do nothing)
  133.     DEFAULT=> \ This means an opcode we don't know anything about.
  134.           \ So we set  MYSTERY? and skip to the end of the field.
  135.         -> unprocessed_code  true -> mystery?
  136.         lim: tmp >pos: tmp
  137.     ]CASE  ;
  138.  
  139.  
  140. : SETUP_OVERRIDES
  141.     pause
  142.     1 ++> ov_blk#
  143.     end: fmt_ov_str  pos: fmt_ov_str
  144.     pad  infoSize: fmt_run  2dup  128 fill  add: fmt_ov_str
  145.         \ set all fields to "leave" initially
  146.     >pos: fmt_ov_str
  147.     end: para_ov_str  pos: para_ov_str
  148.     pad  infoSize: para_run  2dup
  149.     bounds  DO   $ 8000  i w!   2 +LOOP
  150.     add: para_ov_str
  151.     >pos: para_ov_str
  152.     BEGIN
  153.         len: tmp 1 >
  154.     WHILE
  155.         setup_1_override
  156.     REPEAT  ;
  157.  
  158. : TURN_OV_OFF        \ ( dest -- )
  159.     false -> ov_on?
  160.     pad !
  161.     pad 4+  infoSize: fmt_run  128 fill
  162.     pad  itemSize: fmt_run  add: fmt_ov_run   ;
  163.  
  164.  
  165. :loc  FIX_OVERRIDE
  166.     override_marker  ov_on?  or  0EXIT    \ Out if we don't need an
  167.                         \ override entry here
  168.     override_marker  NIF  this_dst turn_ov_off  EXIT  THEN
  169.     true -> ov_on?
  170.     override_marker  $ 8000 and
  171.     NIF    \ It's immediate - create new ov str entries and make indirect.
  172.         save: tmp
  173.           src copyto: tmp
  174.           -2 skip: tmp  2 >len: tmp
  175.           setup_overrides        \ Actually, there's only 1
  176.         restore: tmp
  177.         ov_blk# 1-  $ 8000 or  -> override_marker
  178.     THEN
  179.         \ Now put new entry into FMT_OV_RUN
  180.     this_dst  +L: fmt_ov_run
  181.     infoSize: fmt_run  dup
  182.     override_marker $ 7FFF and *  >pos: fmt_ov_str  >len: fmt_ov_str
  183.     fmt_ov_str  $add: fmt_ov_run  ;loc
  184.  
  185.  
  186. : SETUP_CHANGE        \ ( code -- )
  187.     CASE[ 1    ]=>    setup_overrides
  188.         [ 2    ]=>    setup_offsets
  189.       DEFAULT=>    -> unprocessed_code  true -> mystery?
  190.     ]CASE
  191.     lim: tmp >pos: tmp  ;
  192.  
  193.  
  194. \         ======= Applying the changes =======
  195.  
  196. : EXTEND_TEXT        \ Yes, this can happen, if changes insert stuff!
  197. \    pos: text  real_text_len  <=
  198. \    IF    \ Extending at or before the end.  Adjust real_text_len
  199. \        len: theFile  len: text -  ++> real_text_len
  200. \    THEN
  201.     pos: text  dup  len: theFile  +        \ Desired length
  202.     setsize: text  >pos: text  ;
  203.  
  204.  
  205. : CHANGE_TEXT
  206.     reset: text  reset: changes
  207.     0 -> text&hf_len
  208.     #changes 0 ?DO
  209.         nxtL: changes >pos: theFile
  210.         nxtL: changes >len: theFile
  211.         nxtL: changes >pos: text
  212.         len: theFile  len: text  >  IF  extend_text  THEN
  213.         theFile  $ovwr: text
  214.         pos: text   text&hf_len  max  -> text&hf_len
  215.         2 skip: changes  ( we don't use the override marker here )
  216.     LOOP
  217.     real_text_len text&hf_len max setsize: text  ;
  218.  
  219.  
  220. : FIND_OV_POSN
  221.     override_marker  ?dup  0EXIT
  222.     $ 7FFF and
  223.     infoSize: para_run *  >pos: para_ov_str  ;
  224.  
  225.  
  226. : FIND_PLACE  { offs -- }
  227.     BEGIN
  228.         len: changes  0EXIT
  229.         offs  ^1st: changes @  ^1st: changes 4+ @ +
  230. \        doing_paras?  IF  <=  ELSE  <  THEN
  231.         <=
  232.         ?EXIT
  233.         14 skip: changes
  234.     AGAIN  ;
  235.  
  236. : DIFFERENT_CHANGE_BLK  { offs -- }
  237.     offs find_place
  238.     len: changes
  239.     IF
  240.         ^1st: changes 12 + w@  -> override_marker
  241.         find_ov_posn
  242.     ELSE
  243.         0 -> override_marker
  244.     THEN  ;
  245.  
  246. : CHANGE_OFFSET  { offs -- offs' }    \ Returns -1 if offs is outside limits.
  247.     chg-blk? -> chgd-blk?
  248.     fast?         NIF   offs    EXIT  THEN
  249.     len: changes    NIF   -1    EXIT  THEN
  250.  
  251.     offs  ^1st: changes @  ^1st: changes 4+ @ +
  252. \    doing_paras?  IF  >  ELSE  >=  THEN
  253.     >
  254.     dup -> chg-blk?
  255.     IF
  256.         offs  different_change_blk
  257.         len: changes  NIF  -1  EXIT  THEN
  258.     THEN
  259.     offs  ^1st: changes @  -
  260.     0 max                \ Coerce font change rightward
  261.                     \  after a deletion
  262.     ^1st: changes 8 + @  +  ;    \ Return transformed offset
  263.  
  264.  
  265. : ?DO_PARA_OVERRIDE        \ Note: para_run POS is at the start of the
  266.                 \ styles field.
  267.     override_marker  0EXIT
  268.     ^1st: para_ov_str  w@  dup  $ 8000 <>
  269.     IF  ^1st: para_run  w!  ELSE  drop  THEN  ;
  270.  
  271. \    pos: para_run
  272. \    infoSize: para_run  0  DO
  273. \        ^1st: para_ov_str i + w@  dup  $ 8000  <>
  274. \        IF  >nxtw: para_run  ELSE  drop  2 skip: para_run  THEN
  275. \    2 +LOOP
  276. \    >pos: para_run   ;
  277.  
  278.  
  279. \        ======= Miscellaneous useful words =======
  280.  
  281. : SETUP_BLKS    \ ( -- #blks )
  282.     theFile copyto: dst
  283.     len: dst  4-  6 /   ( # blks )
  284.     dup 1+ 4*  skip: dst
  285.     reset: changes   false -> chg-blk?  false -> chgd-blk?  ;
  286.  
  287. : NEXT_OFFS  { \ offs -- offs }
  288.     save_offs -> offs
  289.     unmpd_new -> unmpd_old
  290.     nxtl: buf  hdr_len -  dup -> unmpd_new
  291.     change_offset  -> save_offs
  292.     doing_paras?  NIF  offs  EXIT  THEN
  293.  
  294. \ For paras, we have to make sure that the incoming para offsets correspond
  295. \ to the RET chars in the text, since changes might have deleted or inserted 
  296. \ extra RETs.  We do this here.  What this amounts to is that we have to find
  297. \ the RET which begins the para immediately before where SAVE_OFFS points.
  298. \ We return the offs of this para (i.e. the offs of RET plus 1).
  299.  
  300.     start: text  save_offs 1 max  >lim: text  -1 more: text
  301.     RET  <chsearch: text  pos: text  +  ;    \ If RET found, skip it
  302.  
  303.  
  304. : NEXT_ITEM?    \ ( -- offs T | F )
  305.     next_offs
  306.     chgd-blk?
  307.     IF    dup  true  doing_paras?
  308.         IF    find_posn: para_run
  309.         ELSE    find_posn: fmt_run
  310.         THEN
  311.     THEN
  312.     ( offs )  dup  0>=  dup NIF  nip  1 skip: buf_offsets  THEN  ;
  313.  
  314.  
  315. \        ======== Merging formats ========
  316.  
  317. \ This isn't fun!!
  318.  
  319. : MERGE1  { offs -- }
  320.     offs  +L: fmt_run
  321.     pos: src  ( save )
  322.       4 skip: src  infoSize: fmt_run  >len: src
  323.       pos: fmt_run   src  $add: fmt_run   >pos: fmt_run
  324.     >pos: src  nolim: src
  325.     4 skip: fmt_ov_run
  326.     infoSize: fmt_run  0  DO
  327.         ^1st: fmt_ov_run i + c@  dup 128 <>
  328.         IF  >nxtc: fmt_run  ELSE  drop  1 skip: fmt_run  THEN
  329.     LOOP
  330.     ^1st: fmt_ov_run 10 + c@  128 <>
  331.     IF  ( kludge to make sure font# 128 works )
  332.         ^1st: fmt_ov_run 11 + c@   ^1st: fmt_run  3 -  c!
  333.     THEN
  334.     -4 skip: fmt_ov_run  ;
  335.  
  336.  
  337.     0    value    PREV        \ Holds offset in SRC of last entry read
  338.                 \ -- this is the one currently in effect
  339.  
  340.  
  341. : DO_LIMIT  { limit -- }    \ Generates new fmt_run entry for override
  342.                 \ change at the limit
  343.     skip_item: fmt_ov_run
  344.     prev 0<
  345.     IF  \ No SRC entry valid yet.  Just copy ov entry over
  346.         itemSize: fmt_run  >len: fmt_ov_run
  347.         fmt_ov_run  $add: fmt_run
  348.         nolim: fmt_ov_run
  349.     ELSE
  350.         prev  swappos: src
  351.             limit merge1
  352.           <skip_item: fmt_ov_run
  353.         >pos: src
  354.     THEN  ;
  355.  
  356. : MERGE_TO_LIMIT  { limit \ src-offs done? do-lim? -- }
  357.     false -> done?  false -> do-lim?
  358.     BEGIN
  359.         len: src
  360.         IF
  361.             ^1st: src @  -> src-offs
  362.             src-offs limit 2dup
  363.             > -> do-lim?  >= -> done?
  364.         ELSE
  365.         \ No formats left.  We may, however, have to generate a
  366.         \ fmt_run entry for the limit.  We only need to do this 
  367.         \ if it is a "real" (not a dummy) limit.
  368.  
  369.             limit big# <> -> do-lim?  true -> done?
  370.         THEN
  371.         do-lim?  IF  limit do_limit  EXIT  THEN
  372.         done?  ?EXIT
  373.         src-offs merge1
  374.         pos: src  -> prev   skip_item: src
  375.     AGAIN  ;
  376.  
  377. : (MERGE_FMTS)
  378.     -1 -> prev  ( means not valid yet )
  379.     BEGIN
  380.         pause
  381.         len: fmt_ov_run
  382.         NIF  ( no more overrides left - copy rest of src over )
  383.             src  $add: fmt_run  EXIT
  384.         THEN
  385.         len: src
  386.         NIF
  387.             <skip_item: src
  388.             BEGIN
  389.                 len: fmt_ov_run  0EXIT
  390.                 ^1st: fmt_ov_run @  merge1
  391.                 skip_item: fmt_ov_run
  392.             AGAIN
  393.         THEN
  394.         len: fmt_ov_run  itemSize: fmt_ov_run  >
  395.         IF    ^1st: fmt_ov_run  itemSize: fmt_ov_run  +  @
  396.         ELSE    big#
  397.         THEN
  398.         merge_to_limit
  399.         skip_item: fmt_ov_run
  400.     AGAIN  ;
  401.  
  402.  
  403. : MERGE_FMTS
  404.     fast?  0EXIT
  405.     reset: fmt_ov_run
  406.     len: fmt_ov_run  0EXIT      \ Out if nothing to merge
  407.     fmt_run  copyto: src  reset: src
  408.     new: fmt_run
  409.     (merge_fmts)            \ Do it
  410.     release: src  ;
  411.  
  412.  
  413. \        ======= Style sheet operations =======
  414.  
  415. \ The string of style names has the level names first, in reverse order,
  416. \ then any synonym(s) for "Normal" (empty if none), then the ordinary
  417. \ styles in forward order.
  418.  
  419. scon    NORM_STYLE "Normal"
  420.  
  421. hex
  422. table    DFLT_FONT
  423.     05001800 ,  dflt_font# c,  18 c,    \ Default: Geneva 12
  424. end_table
  425.  
  426. table    DFLT_PARA
  427. \    07000000 , 0 ,
  428.     03000000 ,
  429. end_table
  430. decimal
  431.  
  432.  
  433. : SKIP1NAME
  434. \    is1st# 255 of> style_names
  435.     1st: style_names  $ FF  =
  436.     IF    1 skip: style_names
  437.     ELSE    count: style_names  step: style_names
  438.     THEN  ;
  439.  
  440.  
  441. : COUNT_STYLES
  442.     reset: style_names  0 -> #styles
  443.     BEGIN
  444.         len: style_names
  445.     WHILE
  446.         skip1name  1 ++> #styles
  447.     REPEAT  ;
  448.  
  449.  
  450. : GET_STYLE_NAME  { n \ cnt -- addr len }    \ Exported.
  451.     n  NIF  norm_style  EXIT  THEN
  452.     reset: style_names  #levels negate  -> cnt
  453.     BEGIN
  454.         len: style_names  NIF  0 0  EXIT  THEN
  455.         cnt n =
  456.         IF
  457. \            is1st# 255 of> style_names  IF  0 0  EXIT  THEN
  458.             1st: style_names  $ FF  =  IF  0 0  EXIT  THEN
  459.             count: style_names  get: style_names  EXIT
  460.         THEN
  461.         skip1name
  462.         1 ++> cnt
  463.     AGAIN  ;
  464.  
  465.  
  466. : GET_STYLE#  { addr len \ n -- n }    \ Exported.
  467.         \ Maybe we should handle synonyms at some stage, if
  468.         \ anyone wants it.
  469.     addr len  norm_style  s=  IF  0  EXIT  THEN
  470.     reset: style_names  #levels negate  -> n
  471.     BEGIN
  472.         len: style_names
  473.         NIF  \ Put new style name in
  474.             len +: style_names
  475.             addr len  add: style_names
  476.             1 ++> #styles  n  EXIT
  477.         THEN
  478. \        is1st# 255 of> style_names
  479.         1st: style_names  $ FF  =
  480.         IF    1 skip: style_names
  481.         ELSE
  482.             count: style_names
  483.             get: style_names  addr len  s=
  484.             IF  n  EXIT  THEN
  485.             step: style_names
  486.         THEN
  487.         1 ++> n
  488.     AGAIN  ;
  489.  
  490.  
  491. : DUMMY_LEVEL_INFO
  492.     reset: style_names
  493.     pad #levels  2dup  -1 fill  add: src
  494.     #levels 0 ?DO  skip1name  LOOP  ;
  495.  
  496. : SS_FORMATS
  497.     dummy_level_info        \ Dummy formats
  498.     dflt_font  add: src        \ Default format for Normal style
  499.     skip1name            \ Skip Normal name
  500.     #styles #levels -  1  ?DO    \ Put in dummy formats
  501. \        is1st# 255 of> style_names
  502.         1st: style_names  $ FF  =
  503.         IF    $ FF  +c: src   1 skip: style_names
  504.         ELSE
  505.             0 +c: src
  506.             count: style_names  step: style_names
  507.         THEN
  508.     LOOP
  509.     reset: src  len: src  2+  2 +n: dst  src  $add: dst   ;
  510.  
  511. : SS_PARAS
  512.     clear: src
  513.     dummy_level_info
  514.     #styles #levels -  0  ?DO
  515. \        is1st# 255 of> style_names
  516.         1st: style_names  $ FF  =
  517.         IF    $ FF  +c: src   1 skip: style_names
  518.         ELSE
  519.             dflt_para  add: src
  520.             i  ^1st: src  3 -  c!
  521.             count: style_names  step: style_names
  522.         THEN
  523.     LOOP
  524.     reset: src  len: src  2+  2 +n: dst  src  $add: dst  ;
  525.  
  526.  
  527. : SETUP_STYLE_SHEET
  528.     new: src  new: dst
  529.     size: style_names
  530.     IF
  531.         count_styles
  532.     ELSE    \ There must be at least a "normal" style, or Word will
  533.         \ crash!  So we'll put one in.
  534.         0 +c: style_names  1 -> #styles
  535.     THEN
  536.     reset: style_names
  537.     #levels  +W: dst  len: style_names  2+  +W: dst
  538.     style_names  $add: dst
  539.     ss_formats
  540.     ss_paras
  541.     #styles  2 +N: dst
  542.     pad  #levels 2*  2dup erase  add: dst  $ 00DE  2 +n: dst
  543.     #styles #levels - 1-  0 ?DO  0  2 +n: dst  LOOP
  544.     reset: dst  release: src  ;
  545.  
  546. : NEED_LEVEL  { lev# \ n -- }
  547.         \ Exported.  Ensures that the number of levels we
  548.         \ have is at least lev#.
  549.  
  550.     lev# #levels -  -> n
  551.     n  0<=  ?EXIT
  552.     start: style_names
  553.     pad n  2dup  -1 fill  insert: style_names
  554.     lev# -> #levels  ;
  555.  
  556. \        ==============================
  557.  
  558. :class  SD    super(  object  )
  559.  
  560.     var    START
  561.     int    LENGTH
  562.  
  563. :m  GET:  get: start  get: length  ;m
  564. :m  PUT:  put: length  put: start  ;m
  565. :m  USE:  get: self  swap  hdr_len -  >pos: theFile  >len: theFile  ;m
  566.  
  567.  
  568. ;class
  569.  
  570.  
  571. variable  STYLES  -4 allot
  572. here
  573.   hex
  574.     80  c,        \ bold
  575.     40  c,        \ italic
  576.     20  c,        \ strikethru
  577.     10  c,        \ outline
  578.     08  c,        \ shadow
  579.     04  c,        \ small caps
  580.     02  c,        \ all caps
  581.     01  c,        \ hidden
  582.   decimal
  583. here swap -  constant    STYLES_LEN
  584.